home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / dbx.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-01-30  |  43.3 KB  |  1,797 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* interface to dbx for sem debugging */
  10. /* interface to dbx for sem debugging */
  11. #include "hdr.h"
  12. #include "libhdr.h"
  13. #include "vars.h"
  14. #include "ifile.h"
  15. #include "setp.h"
  16. #include "arithp.h"
  17. #include "sspansp.h"
  18. #include "chapp.h"
  19. #include "librp.h"
  20. #include "miscp.h"
  21. #include "smiscp.h"
  22. #include "dbxp.h"
  23.  
  24. #ifndef EXPORT
  25.  
  26. typedef struct explored
  27. {
  28.     short genre;    /* discriminant : is explored a node or a symbol ? */
  29.  
  30.     union {
  31.         Node   n;
  32.         Symbol s;
  33.     } addr;
  34. } explored;
  35.  
  36. #define UNDEFINED_STEP 99
  37. #define EXIT_STEP 100
  38. #define NODE_GENRE 0
  39. #define SYMBOL_GENRE 1
  40.  
  41.  
  42.  
  43. int zpadr_opt = 1;
  44. Symbol zsym;
  45. Set    zset;
  46. Node    znod;
  47. Declaredmap    zdcl;
  48. Tuple ztup;
  49. void give_node_reference(Node);
  50. void give_symbol_reference(Symbol);
  51. void zpnodrefa(char *, Node);
  52. void zpset(Set);
  53. void zpsig(Symbol);
  54. void zpsigt();
  55. void zptup(Tuple);
  56. void zpsetsym(Set);
  57. void zpsym(Symbol);
  58. void zpsymrefa(char *, Symbol);
  59. void zpsymref(Symbol);
  60. void zpnodref(Node);
  61. int analyze(char *, explored, int *, int *);
  62.  
  63. static int adrflag = 1; /* non zero to print address values */
  64. static int stack_ptr = 0;
  65. static explored stack[ 100 ];
  66. static void push(explored);
  67. static explored pop();
  68. static void display_symbol(Symbol);
  69. static void zpcon1(Const);
  70. static void zprat1(Rational);
  71.  
  72.  
  73. /*
  74.  * The purpose of this program is to provide the one who is not familiar
  75.  * with the structure of the AST with a tool which permits him to travel
  76.  * from one node to his eventual father or son (we assume that the
  77.  * beginning of the exploration will take place at the root of the AST .)
  78.  * and focus on the nodes he wants to examine more precisely in a readable
  79.  * way . 
  80.  */
  81.  
  82.  
  83. static void push (explored site)                /*;push*/
  84. {
  85.     stack [ stack_ptr++ ] = site;
  86. }
  87.  
  88. static explored pop ()                    /*;pop*/
  89. {
  90.     return (stack [ --stack_ptr ]);
  91. }
  92.  
  93. static void display_symbol(Symbol symbol_explored)        /*;display_symbol*/
  94. {
  95.     short nature;
  96.  
  97.     system ("clear");
  98.  
  99.     if (symbol_explored == (Symbol)0)
  100.         printf ("(Symbol)0\n");
  101.     else {
  102.         printf("NATURE %s        %d \n\n",
  103.           nature_str (NATURE (symbol_explored)), symbol_explored);
  104.         printf("TYPE_OF %s   %d\n",
  105.           nature_str(NATURE(TYPE_OF(symbol_explored))),
  106.           TYPE_OF(symbol_explored));
  107.         printf("ALIAS   %s   %d\n",
  108.           nature_str(NATURE(ALIAS(symbol_explored))), ALIAS(symbol_explored));
  109.         printf("SIGNATURE :\n");
  110.     
  111.         if (SIGNATURE (symbol_explored) != ((Tuple)0))
  112.             zptup(SIGNATURE (symbol_explored));
  113.         else
  114.             printf("empty_tuple\n");
  115.  
  116.         if (SCOPE_OF(symbol_explored))
  117.             printf("SCOPE_OF %s   %d\n",
  118.               nature_str(NATURE(SCOPE_OF(symbol_explored))),
  119.               SCOPE_OF(symbol_explored));
  120.         else
  121.             printf("No scope.\n");
  122.  
  123.         printf("OVERLOADS :\n");
  124.         if (OVERLOADS (symbol_explored) != ((Tuple)0)) {
  125.             nature = NATURE(symbol_explored);
  126.             if (nature == na_enum)
  127.                 printf(" literal map %d\n", OVERLOADS(symbol_explored));
  128.             else if (nature == na_package || nature == na_package_spec
  129.               || nature == na_generic_package_spec
  130.               || nature == na_generic_package || nature == na_task_type
  131.               || nature == na_task_obj)
  132.                 printf(" private declarations %d\n",
  133.                     OVERLOADS(symbol_explored));
  134.             else 
  135.                 display_symbol_list  (OVERLOADS (symbol_explored), 1);
  136.         }
  137.         else
  138.             printf ("empty_set\n");
  139.         printf("DECLARED %d\n", DECLARED (symbol_explored));
  140.         if (ORIG_NAME (symbol_explored) != (char *)0)
  141.             printf("ORIG_NAME %s\n", ORIG_NAME (symbol_explored));
  142.         printf("SEQ %d\n", S_SEQ (symbol_explored));
  143.         printf("UNIT %d\n", S_UNIT (symbol_explored));
  144.         printf("TYPE_ATTR %d\n", TYPE_ATTR (symbol_explored));
  145.         if (MISC (symbol_explored) != (char *)0)
  146.             printf("MISC %s\n", MISC (symbol_explored));
  147.         printf("TYPE_KIND %d\n", TYPE_KIND (symbol_explored));
  148.         printf("TYPE_SIZE %d\n", TYPE_SIZE (symbol_explored));
  149.  
  150.         if (INIT_PROC(symbol_explored))
  151.             printf("INIT_PROC %s   %d\n",
  152.               nature_str(NATURE(INIT_PROC(symbol_explored))),
  153.               INIT_PROC(symbol_explored));
  154.         else printf("INIT_PROC = 0\n");
  155.  
  156.         printf("ASSOCIATED_SYMBOLS :\n");
  157.         if (ASSOCIATED_SYMBOLS (symbol_explored) != ((Tuple)0))
  158.             display_symbol_list (ASSOCIATED_SYMBOLS (symbol_explored), 1);
  159.         else
  160.             printf ("empty_tuple\n");
  161.         printf("SEGMENT %d\n", S_SEGMENT (symbol_explored));
  162.         printf("OFFSET %d\n", S_OFFSET (symbol_explored));
  163.         printf("\n");
  164.     }
  165. }
  166.  
  167. void display_node(Node node_explored, int list_begin)    /*;display_node*/
  168. {
  169.     int kind_explored;
  170.  
  171.     system ("clear");
  172.  
  173.     if (node_explored == (Node)0)
  174.         printf ("(Node)0\n");
  175.     else {
  176.         kind_explored = N_KIND (node_explored);
  177.  
  178.         printf ("kind -> %s  ", kind_str (kind_explored));
  179.         printf ("unit -> %d  ", N_UNIT (node_explored));
  180.         printf ("side -> %d  ", N_SIDE (node_explored));
  181.         printf ("overloaded -> %d  ", N_OVERLOADED (node_explored));
  182.         printf ("sequence -> %d ", N_SEQ (node_explored));
  183.         printf ("\n");
  184.         printf ("%d", kind_explored);
  185.  
  186.         printf ("\n");
  187.         printf ("\n");
  188.  
  189.         /*****************/
  190.         /* nu1 component */
  191.         /*****************/
  192.         printf (" nu1 :  ");
  193.  
  194.         if (N_AST1_DEFINED (kind_explored)) {
  195.             if (N_AST1(node_explored) != (Node)0)
  196.                 printf ("AST1 %s \n", kind_str(N_KIND(N_AST1(node_explored))));
  197.             else
  198.                 printf ("AST1 (Node)0 \n");
  199.         }
  200.         else 
  201.             printf ("SPAN %d %d \n", N_SPAN0 (node_explored),
  202.               N_SPAN1 (node_explored));
  203.  
  204.         printf ("\n");
  205.  
  206.         /*****************/
  207.         /* nu2 component */
  208.         /*****************/
  209.         printf (" nu2 :  ");
  210.  
  211.         if (N_AST2_DEFINED (kind_explored)) {
  212.             if (N_AST2(node_explored) != (Node)0)
  213.                 printf ("AST2 %s \n",
  214.                     kind_str(N_KIND(N_AST2(node_explored))));
  215.             else
  216.                 printf ("AST2 (Node)0 \n");
  217.         }
  218.         else if (N_LIST_DEFINED (kind_explored)) {
  219.             printf ("LIST ");
  220.             if (N_LIST (node_explored) != ((Tuple)0))
  221.                 display_node_list (N_LIST (node_explored), list_begin);
  222.             else 
  223.                 printf ("empty_tuple\n");
  224.         }
  225.         else { /* (N_VAL_DEFINED (kind_explored) */
  226.             display_value (node_explored);
  227.             printf ("\n");
  228.         }
  229.  
  230.         printf ("\n");
  231.  
  232.         /*****************/
  233.         /* nu3 component */
  234.         /*****************/
  235.         printf (" nu3 :  ");
  236.  
  237.         if (N_AST3_DEFINED (kind_explored)) {
  238.             if (N_AST3(node_explored) != (Node)0)
  239.                 printf ("AST3 %s \n", kind_str(N_KIND(N_AST3(node_explored))));
  240.             else
  241.                 printf ("AST3 (Node)0 \n");
  242.         }
  243.         else if (N_UNQ_DEFINED (kind_explored))
  244.             printf ("Symbol unq --> %s \n",
  245.               nature_str(NATURE(N_UNQ(node_explored))));
  246.         else {
  247.             printf ("N_NAMES ");
  248.             if (N_NAMES (node_explored) != ((Set)0))
  249.                 display_node_list((Tuple)N_NAMES(node_explored), list_begin);
  250.             else 
  251.                 printf ("empty_set\n");
  252.         }
  253.  
  254.         printf ("\n");
  255.  
  256.         /*****************/
  257.         /* nu4 component */
  258.         /*****************/
  259.         printf (" nu4 :  ");
  260.  
  261.         if (N_AST4_DEFINED (kind_explored)) {
  262.             if (N_AST4(node_explored) != (Node)0)
  263.                 printf ("AST4 %s \n", kind_str(N_KIND(N_AST4(node_explored))));
  264.             else
  265.                 printf ("AST4 (Node)0 \n");
  266.         }
  267.         else if (N_TYPE_DEFINED (kind_explored))
  268.             printf ("Symbol type --> %s \n",
  269.               nature_str(NATURE(N_TYPE(node_explored))));
  270.         else {
  271.             printf ("N_PTYPES ");
  272.             if (N_PTYPES (node_explored) != ((Set)0))
  273.                 display_node_list((Tuple)N_PTYPES(node_explored), list_begin);
  274.             else 
  275.                 printf ("empty_set\n");
  276.         }
  277.         printf ("\n");
  278.     }
  279. }
  280.  
  281. void explorast (Node root)                    /*;explorast*/
  282. {
  283.     explored current;
  284.     int      next_step;
  285.     int      list_node;
  286.     int      list_low;
  287.     char     answer[10];
  288.  
  289.     current.genre = NODE_GENRE;
  290.     current.addr.n = root;
  291.     list_low = 1;
  292.  
  293.     do {
  294.         if (current.genre == NODE_GENRE)
  295.             display_node   (current.addr.n, list_low);
  296.         else 
  297.             display_symbol (current.addr.s);
  298.  
  299.         next_step = UNDEFINED_STEP;
  300.         list_node = 0;
  301.  
  302.         while (next_step == UNDEFINED_STEP) {
  303.             printf (" what shall be the next step  ?  ");
  304.             scanf ("%10s", answer);
  305.             next_step = analyze (answer, current, &list_node, &list_low);
  306.         }
  307.  
  308.         switch (next_step) {
  309.         case 0 :
  310.             current = pop ();
  311.             break;
  312.         case 11:
  313.             push (current);
  314.             current.genre  = NODE_GENRE;
  315.             current.addr.n = N_AST1 (current.addr.n);
  316.             break;
  317.         case 21:
  318.             push (current);
  319.             current.genre  = NODE_GENRE;
  320.             current.addr.n = N_AST2 (current.addr.n);
  321.             break;
  322.         case 22:
  323.             push (current);
  324.             current.genre  = NODE_GENRE;
  325.             current.addr.n = (Node)((N_LIST(current.addr.n))[list_node]);
  326.             break;
  327.         case 31:
  328.             push (current);
  329.             current.genre  = NODE_GENRE;
  330.             current.addr.n = N_AST3 (current.addr.n);
  331.             break;
  332.         case 33:
  333.             push (current);
  334.             current.genre  = SYMBOL_GENRE;
  335.             current.addr.s = N_UNQ (current.addr.n);
  336.             break;
  337.         case 41:
  338.             push (current);
  339.             current.genre  = NODE_GENRE;
  340.             current.addr.n = N_AST4 (current.addr.n);
  341.             break;
  342.         case 43:
  343.             push (current);
  344.             current.genre  = SYMBOL_GENRE;
  345.             current.addr.s = N_TYPE (current.addr.n);
  346.             break;
  347.         case 91:
  348.             push (current);
  349.             current.genre  = SYMBOL_GENRE;
  350.             current.addr.s = TYPE_OF (current.addr.s);
  351.             break;
  352.         case 92:
  353.             push (current);
  354.             current.genre  = SYMBOL_GENRE;
  355.             current.addr.s = SCOPE_OF (current.addr.s);
  356.             break;
  357.         case 93:
  358.             push (current);
  359.             current.genre  = SYMBOL_GENRE;
  360.             current.addr.s = ALIAS (current.addr.s);
  361.             break;
  362.         case 94:
  363.             push (current);
  364.             current.genre  = SYMBOL_GENRE;
  365.             current.addr.s = INIT_PROC (current.addr.s);
  366.             break;
  367.         case 999:
  368.             break;
  369.         }
  370.     } while (next_step != EXIT_STEP);
  371. }
  372.  
  373. int analyze (char *way, explored current, int *p_list_num, int *p_list_low)
  374.                                                                     /*;analyze*/
  375. {
  376.     Node   current_node;
  377.     int    current_kind;
  378.     Symbol current_symbol;
  379.     int    current_nature;
  380.  
  381.     if (current.genre == NODE_GENRE) {
  382.         current_node = current.addr.n;
  383.  
  384.         if (current_node != (Node)0)
  385.             current_kind = N_KIND (current_node);
  386.  
  387.         switch (way [0]) {
  388.         case 'f' : 
  389.             if (stack_ptr == 0) {
  390.                 printf (" Illegal step : You are at the ROOT\n");
  391.                 return (UNDEFINED_STEP);
  392.             }
  393.             else
  394.                 return (0);
  395.         case '1' : 
  396.             if ((current_node != (Node)0) && (N_AST1_DEFINED (current_kind)))
  397.                 return (11);
  398.             else {
  399.                 printf (" Illegal step : AST1 undefined\n");
  400.                 return (UNDEFINED_STEP);
  401.             }
  402.         case '2' : 
  403.             if ((current_node != (Node)0) && (N_AST2_DEFINED (current_kind)))
  404.                 return (21);
  405.             else {
  406.                 printf (" Illegal step : AST2 undefined\n");
  407.                 return (UNDEFINED_STEP);
  408.             }
  409.         case '3' : 
  410.             if ((current_node != (Node)0) && (N_AST3_DEFINED (current_kind)))
  411.                 return (31);
  412.             else {
  413.                 printf (" Illegal step : AST3 undefined\n");
  414.                 return (UNDEFINED_STEP);
  415.             }
  416.         case '4' : 
  417.             if ((current_node != (Node)0) && (N_AST4_DEFINED (current_kind)))
  418.                 return (41);
  419.             else {
  420.                 printf (" Illegal step : AST4 undefined\n");
  421.                 return (UNDEFINED_STEP);
  422.             }
  423.         case 'l' : 
  424.             if ((current_node != (Node)0) && (N_LIST_DEFINED (current_kind))) {
  425.                 if (atoi (way + 1) > 0
  426.                   && atoi (way + 1) <= tup_size(N_LIST(current_node))) {
  427.                     *p_list_num = atoi (way + 1);
  428.                     return (22);
  429.                 }
  430.                 else {
  431.                     printf (" Illegal list number\n");
  432.                     return (UNDEFINED_STEP);
  433.                 }
  434.             }
  435.             else {
  436.                 printf (" Illegal step : LIST undefined\n");
  437.                 return (UNDEFINED_STEP);
  438.             }
  439. #ifdef PRETTY
  440.         case 's' : 
  441.             if ((current_node != (Node)0) && (N_LIST_DEFINED (current_kind))) {
  442.                 if (atoi (way + 1) > 0
  443.                   && atoi (way + 1) <= tup_size(N_LIST(current_node))) {
  444.                     *p_list_num = atoi (way + 1);
  445.                     regenerate_source1( N_LIST(current_node)[*p_list_num],
  446.                       stack[stack_ptr - 1].addr.n);
  447.                     printf("\n");
  448.                     return (UNDEFINED_STEP);
  449.                 }
  450.                 else {
  451.                     printf (" Illegal list number\n");
  452.                     return (UNDEFINED_STEP);
  453.                 }
  454.             }
  455.             else {
  456.                 printf (" Illegal step : LIST undefined\n");
  457.                 return (UNDEFINED_STEP);
  458.             }
  459. #endif
  460.         case 'v' : 
  461.             if ((current_node != (Node)0) && (N_LIST_DEFINED (current_kind))) {
  462.                 if (atoi (way + 1) <= tup_size(N_LIST(current_node))) {
  463.                     *p_list_low = atoi (way + 1);
  464.                     return (999);
  465.                 }
  466.                 else {
  467.                     printf (" Illegal list number\n");
  468.                     return (UNDEFINED_STEP);
  469.                 }
  470.             }
  471.             else {
  472.                 printf (" Illegal step : LIST undefined\n");
  473.                 return (UNDEFINED_STEP);
  474.             }
  475.         case 'u' : 
  476.             if ((current_node != (Node)0) && (N_UNQ_DEFINED (current_kind)))
  477.                 return (33);
  478.             else {
  479.                 printf (" Illegal step : UNQ undefined\n");
  480.                 return (UNDEFINED_STEP);
  481.             }
  482.         case 't' : 
  483.             if ((current_node != (Node)0) && (N_TYPE_DEFINED (current_kind)))
  484.                 return (43);
  485.             else {
  486.                 printf (" Illegal step : TYPE undefined\n");
  487.                 return (UNDEFINED_STEP);
  488.             }
  489.         case 'q' : 
  490.             stack_ptr = 0;
  491.             return (EXIT_STEP);
  492.         case 'h' : 
  493.             printf (" 1     ==> see AST1            \n");
  494.             printf (" 2     ==> see AST2            \n");
  495.             printf (" 3     ==> see AST3            \n");
  496.             printf (" 4     ==> see AST4            \n");
  497.             printf (" l num ==> see list node num   \n");
  498.             printf (" v num ==> see list begin num  \n");
  499.             printf (" u     ==> see unq             \n");
  500.             printf (" t     ==> see type            \n");
  501.             return (UNDEFINED_STEP);
  502.         default  : 
  503.             printf(" I do not understand where you want to go\n");
  504.             return (UNDEFINED_STEP);
  505.         }
  506.     }
  507.     else {
  508.         current_symbol = current.addr.s;
  509.  
  510.         if (current_symbol != (Symbol)0)
  511.             current_nature = NATURE (current_symbol);
  512.  
  513.         switch (way [0]) {
  514.         case 'f' : 
  515.             if (stack_ptr == 0) {
  516.                 printf (" Illegal step : You are at the ROOT\n");
  517.                 return (UNDEFINED_STEP);
  518.             }
  519.             else
  520.                 return (0);
  521.         case 't' : 
  522.             return (91);
  523.         case 's' : 
  524.             return (92);
  525.         case 'a' : 
  526.             return (93);
  527.         case 'i' : 
  528.             return (94);
  529.         case 'q' : 
  530.             stack_ptr = 0;
  531.             return (EXIT_STEP);
  532.         case 'h' : 
  533.             printf (" t ==> see TYPE_OF   \n");
  534.             printf (" s ==> see SCOPE_OF  \n");
  535.             printf (" a ==> see ALIAS     \n");
  536.             printf (" i ==> see INIT_PROC \n");
  537.             return (UNDEFINED_STEP);
  538.         default  : 
  539.             printf(" I do not understand where you want to go\n");
  540.             return (UNDEFINED_STEP);
  541.         }
  542.     }
  543. }
  544.  
  545. void display_node_list (Tuple tup, int low)                /*;display_node_list*/
  546. {
  547.     int high, i, n;
  548.  
  549.     n = tup_size(tup);
  550.     printf("size : %d\n", n);
  551.     high = low + 10;
  552.     if (high > n)
  553.         high = n;
  554.     for (i = low; i <= high; i++)
  555.         printf("%d 0x%x %d %s \n", i, (int)tup[i], (int)tup[i],
  556.           kind_str(N_KIND((Node)tup[i])));
  557. }
  558.  
  559. void display_symbol_list (Tuple tup, int low)        /*;display_symbol_list*/
  560. {
  561.     int high, i, n;
  562.  
  563.     n = tup_size(tup);
  564.     printf(" size : %d\n", n);
  565.     high = low + 10;
  566.     if (high > n)
  567.         high = n;
  568.     for (i = low; i <= high; i++) {
  569.         printf(" ");
  570.         give_symbol_reference((Symbol)tup[i]);
  571.         zpsymrefa("type_of", TYPE_OF((Symbol)tup[i]));
  572.         zpsymrefa("scope", SCOPE_OF((Symbol)tup[i]));
  573.         if (ORIG_NAME((Symbol)tup[i]) != (char *)0)
  574.             printf(" :%s", ORIG_NAME((Symbol)tup[i]));
  575.         printf("\n");
  576.     }
  577. }
  578.  
  579. void display_value (Node node_explored)                /*;display_value*/
  580. {
  581.     int kind_explored, constant_kind;
  582.     Const constant_explored;
  583.     Rational rational_explored;
  584.     Tuple tup;
  585.     int i, n;
  586.  
  587.     kind_explored = N_KIND (node_explored);
  588.  
  589.     if (kind_explored == as_simple_name
  590.       || kind_explored == as_int_literal
  591.       || kind_explored == as_real_literal
  592.       || kind_explored == as_string_literal
  593.       || kind_explored == as_character_literal
  594.       || kind_explored == as_subprogram_stub_tr
  595.       || kind_explored == as_package_stub
  596.       || kind_explored == as_task_stub)
  597.         printf ("%s", N_VAL (node_explored));
  598.     else if (kind_explored == as_line_no
  599.       || kind_explored == as_number
  600.       || kind_explored == as_predef)
  601.         printf ("%d", (int) N_VAL (node_explored));
  602.     else if (kind_explored == as_mode)
  603.         printf ("%d", (int) N_VAL (node_explored));
  604.     else if (kind_explored == as_ivalue) {
  605.         constant_explored = (Const) N_VAL (node_explored);
  606.         constant_kind = constant_explored -> const_kind;
  607.         if (NATURE(N_TYPE(node_explored)) == na_enum)
  608.             printf ("%s", OVERLOADS(N_TYPE(node_explored))
  609.               [2*constant_explored->const_value.const_int+1]);
  610.         else {
  611.             if (constant_kind == CONST_INT)
  612.                 printf ("%d",  constant_explored->const_value.const_int);
  613.             else if (constant_kind == CONST_REAL)
  614.                 printf ("%f", constant_explored->const_value.const_real);
  615.             else if (constant_kind == CONST_UINT)
  616.                 printf ("%d", constant_explored->const_value.const_uint);
  617.             else if (constant_kind == CONST_OM)
  618.                 printf ("OM");
  619.             else if (constant_kind == CONST_RAT) {
  620.                 rational_explored = constant_explored-> const_value.const_rat;
  621.                 printf ("num %d den %d", rational_explored -> rnum,
  622.                   rational_explored -> rden);
  623.             }
  624.             else if (constant_kind == CONST_CONSTRAINT_ERROR)
  625.                 printf ("CONSTANT_CONSTRAINT_ERROR");
  626.         }
  627.     }
  628.     else if (kind_explored == as_terminate_alt)
  629.     printf ("%d", (int) N_VAL (node_explored));
  630.     else if (kind_explored == as_string_ivalue) {
  631.         /* N_VAL is a tuple of integer */
  632.         printf ("\"");
  633.         tup = (Tuple) N_VAL (node_explored);
  634.         n = tup_size (tup);
  635.         for (i = 1; i <= n; i++)
  636.             printf ("%c", tup [i]);
  637.         printf ("\"");
  638.     }
  639.     else if (kind_explored == as_null)
  640.         printf ("null");
  641.     else if (kind_explored == as_null_s)
  642.         printf ("null;");
  643.     else if (kind_explored == as_others)
  644.         printf ("others");
  645.     else if (kind_explored == as_generic)
  646.         printf ("(<>)");
  647.     else if (kind_explored == as_instance_tuple)
  648.         printf (" ??????? ");
  649. }
  650.  
  651. void display_signature (Symbol sym)                 /*;display_signature*/
  652. {
  653.     int nat, i, n, ctyp;
  654.     Tuple    sig, tup, tupent;
  655.     Symbol    s;
  656.     Fortup    ft1;
  657.     static char *constraint_types[] = {
  658.       "range", "digits", "delta", "discr", "array" };
  659.  
  660.  
  661.     /* The signature field is used as follows:
  662.      * It is a symbol for:
  663.      *    na_access
  664.      * It is a node for
  665.      *    na_constant  na_in  na_inout
  666.      * It is also a node (always OPT_NODE) for na_out. For now we write this
  667.      * out even though it is not used. 
  668.      * It is a pair for na_array.
  669.      * It is a triple for na_enum.
  670.      * It is a triple for na_generic_function_spec na_generic_procedure_spec
  671.      * The first component is a tuple of pairs, each pair consisting of
  672.      * a symbol and a (default) node.
  673.      * The second component is a tuple of symbols.
  674.      * The third component is a node
  675.      * It is a tuple with four elements for na_generic_package_spec:
  676.      * the first is a tuple of pairs, with same for as for generic procedure.
  677.      * the second third, and fourth components are nodes.
  678.      * It is a 5-tuple for na_record.
  679.      * It is a constraint for na_subtype and na_type.
  680.      * It is a node for na_obj.
  681.      * Otherwise it is the signature for a procedure, namely a tuple
  682.      * of quadruples.
  683.      * Note however, that for a private type, the signature has the same
  684.      * form as for a record.
  685.      * For a subtype whose root type is an array, the signature has the
  686.      * same form as for an array.
  687.      */
  688.  
  689.     nat = NATURE(sym);
  690.     sig = SIGNATURE(sym);
  691.  
  692.     /* treat private types way in same way as for records*/
  693.  
  694.     s = TYPE_OF(sym);
  695.     if (s == symbol_private || s == symbol_limited_private
  696.       || s == symbol_incomplete)
  697.         nat = na_record;
  698.  
  699.     switch (nat) {
  700.     case na_access: 
  701.         /* access: signature is designated_type;*/
  702.         (void) give_symbol_reference ((Symbol) sig);
  703.         break;
  704.  
  705.     case na_array:
  706.     array_case:
  707.         /* array: signature is pair [i_types, comp_type] where
  708.          * i_type is tuple of type names
  709.          */
  710.         printf(" array_sig %d\n", tup_size((Tuple) sig[1]));
  711.         FORTUP(s = (Symbol), (Tuple) sig[1], ft1);
  712.             (void) give_symbol_reference (s);
  713.             printf("\n");
  714.         ENDFORTUP(ft1);
  715.         (void) give_symbol_reference ((Symbol) sig[2]);
  716.         printf("\n");
  717.         break;
  718.  
  719.     case    na_block:
  720.         /* block: miscellaneous information */
  721.         /* This information not needed externally*/
  722.         printf ("signature for block\n");
  723.         break;
  724.  
  725.     case    na_constant:
  726.     case    na_in:
  727.     case    na_inout:
  728.     case    na_out:
  729.     case    na_discriminant:
  730.         (void) give_node_reference ((Node) sig);
  731.         break;
  732.  
  733.     case    na_entry:
  734.     case    na_entry_family:
  735.     case    na_entry_former:
  736.         /*  entry: list of symbols */
  737.     case    na_function:
  738.     case    na_function_spec:
  739.     case    na_literal:        /* is this for literals too? */
  740.     case    na_op:
  741.     case    na_procedure:
  742.     case    na_procedure_spec:
  743.         printf(" symbol_list  %d\n", tup_size(sig));
  744.         FORTUP(s = (Symbol), sig, ft1);
  745.             (void) give_symbol_reference(s); 
  746.             printf("\n");
  747.         ENDFORTUP(ft1);
  748.         break;
  749.  
  750.     case na_enum : 
  751.         /* enum: tuple in form ['range', lo, hi]*/
  752.         /* we write this as two node references*/
  753.         (void) give_node_reference ((Node) sig[2]);
  754.         (void) give_node_reference ((Node) sig[3]);
  755.         printf ("\n");
  756.         break;
  757.  
  758.     case na_type: 
  759.     case na_subtype:
  760.         if (nat == na_subtype && is_access(TYPE_OF(sym)))
  761.         /* subtype of access type, signature is anonymous type */
  762.             (void) give_symbol_reference ((Symbol)sig);
  763.         else {
  764.             n = tup_size(sig);
  765.             if (is_array (sym)) {
  766.                 printf(" constrained_array \n");
  767.                 goto array_case;
  768.             }
  769.             ctyp = (int) sig[1];
  770.             if (ctyp >= 0 && ctyp <= 4)
  771.                 printf(" co_%s", constraint_types[ctyp]);
  772.             else
  773.                 printf(" unknown constraint type %d", ctyp);
  774.             if (ctyp == CONSTRAINT_DISCR) {
  775.                 /* discriminant map */
  776.                 tup = (Tuple) numeric_constraint_discr(sig);
  777.                 n = tup_size(tup);
  778.                 for (i = 1; i <= n; i += 2) {
  779.                     printf(" %d", (i+1)/2);
  780.                     (void) give_symbol_reference ((Symbol) sig[i]);
  781.                     (void) give_node_reference ((Node) sig[i+1]);
  782.                 }
  783.             }
  784.             else {
  785.                 for (i = 2; i <= n; i++) {
  786.                     printf(" %d", i);
  787.                     (void) give_node_reference ((Node) sig[i]);
  788.                 }
  789.             }
  790.         }
  791.         printf("\n");
  792.         break;
  793.  
  794.     case    na_generic_function:
  795.     case    na_generic_procedure:
  796.     case    na_generic_function_spec:
  797.     case    na_generic_procedure_spec:
  798.         if (tup_size(sig) != 3)
  799.             printf ("bad signature for na_generic_procedure_spec\n");
  800.         /* tuple count known to be three, just put elements */
  801.         tup = (Tuple) sig[1];
  802.         /* the first component is a tuple of pairs, just write count
  803.          * and the values of the successive pairs 
  804.          */
  805.         n = tup_size(tup);
  806.         printf(" %d\n", n);
  807.         for (i = 1; i <= n; i++) {
  808.             tupent = (Tuple) tup[i];
  809.             (void) give_symbol_reference((Symbol) tupent[1]);
  810.             (void) give_node_reference ((Node) tupent[2]);
  811.             printf("\n");
  812.         }
  813.         tup = (Tuple) sig[2];
  814.         n = tup_size(tup); /* symbol list */
  815.         printf(" symbol_list %d\n", n);
  816.         for (i = 1; i <= n; i++) {
  817.             (void) give_symbol_reference ((Symbol) tup[i]); 
  818.             printf("\n");
  819.         }
  820.         printf(" node ");
  821.         (void) give_node_reference((Node) sig[3]);
  822.         printf("\n");
  823.         break;
  824.  
  825.     case    na_generic_package_spec:
  826.     case    na_generic_package:
  827.         /* signature is tuple with three elements */
  828.         if (tup_size(sig) != 4)
  829.             printf ("bad signature for na_generic_package_spec\n");
  830.         tup = (Tuple) sig[1];
  831.         /* the first component is a tuple of pairs, just write count
  832.          * and the values of the successive pairs 
  833.          */
  834.         n = tup_size(tup);
  835.         printf(" n %d\n", n);
  836.         for (i = 1; i <= n; i++) {
  837.             tupent = (Tuple) tup[i];
  838.             (void) give_symbol_reference ((Symbol) tupent[1]);
  839.             (void) give_node_reference ((Node) tupent[2]);
  840.             printf("\n");
  841.         }
  842.         /* the second third, and fourth components are just nodes */
  843.         (void) give_node_reference ((Node) sig[2]);
  844.         (void) give_node_reference ((Node) sig[3]);
  845.         (void) give_node_reference ((Node) sig[4]);
  846.         printf("\n");
  847.         break;
  848.  
  849.     case    na_record:
  850.         /* the signature is tuple with five components:
  851.          * [node, node, tuple of symbols, declaredmap, node]
  852.          * NOTE: we do not write component count - 5 assumed 
  853.          */
  854.         printf(" record (skip details)\n"); 
  855.         break;
  856. /*
  857.         (void) give_node_reference ((Node) sig[1]);
  858.         (void) give_node_reference ((Node) sig[2]);
  859.         tup = (Tuple) sig[3];
  860.         n = tup_size(tup);
  861.         for (i = 1; i <= n; i++)
  862.             zpsymref((Symbol) tup[i]);
  863.  
  864.         (void) give_node_reference ((Node) sig[5]);
  865.         break;
  866. */
  867.  
  868.     case    na_void:
  869.         /* special case assume entry for $used, in which case is tuple
  870.          * of symbols
  871.          */
  872.         if (streq(ORIG_NAME(sym), "$used")) {
  873.             n = tup_size(sig);
  874.             printf(" symbol_list %d\n", n);
  875.             for (i = 1; i <= n; i++) {
  876.                 (void) give_symbol_reference ((Symbol) sig[i]); 
  877.                 printf("\n");
  878.             }
  879.         }
  880.         else {
  881.             (void) give_symbol_reference(sym);
  882.             printf ("na_void, not $used\n");
  883.         }
  884.         break;
  885.  
  886.     case na_obj:
  887.         (void) give_node_reference ((Node) sig); 
  888.         printf("\n");
  889.         break;
  890.  
  891.     default:
  892.         printf("display_signature : default error\n");
  893.     }
  894. }
  895.  
  896. void give_node_reference (Node node)            /*;give_node_reference*/
  897. {
  898.     if (node == (Node)0)
  899.         printf (" (Node)0 \n");
  900.     else
  901.         printf(" n%du%d %d%s", N_SEQ (node), N_UNIT (node), node,
  902.           kind_str (N_KIND (node)));
  903. }
  904.  
  905. void give_symbol_reference (Symbol symbol)        /*;give_symbol_reference*/
  906. {
  907.     if (symbol == (Symbol)0)
  908.         printf (" (Symbol)0 \n");
  909.     else
  910.         printf(" s%du%d %d%s", S_SEQ (symbol), S_UNIT (symbol), symbol,
  911.           nature_str (NATURE (symbol)));
  912. }
  913.  
  914. void zpadr(char *s, char *p)            /*;zpadr*/
  915. {
  916.     /* print argument as address */
  917.     if (zpadr_opt == 0) return; /* quit if disabled */
  918.     if (p == (char *)0) return; /* don't print if null pointer */
  919.     if (!adrflag) return;
  920.     if (s != (char *)0) {
  921. #ifdef IBM_PC
  922.         printf(" %s %p", s, p);
  923. #else
  924.         printf(" %s %ld", s, p);
  925. #endif
  926.     }
  927.     else {
  928. #ifdef IBM_PC
  929.         printf(" %p", p);
  930. #else
  931.         printf(" %ld", p);
  932. #endif
  933.     }
  934. }
  935.  
  936. void zpstr(char *str)                                            /*;zpstr*/
  937. {
  938.     printf("%s\n", str);
  939. }
  940.  
  941. void zpcon(Const con)                                            /*;zpcon*/
  942. {
  943.     zpcon1(con);
  944.     printf("\n");
  945. }
  946.  
  947. static void zpcon1(Const con)                                    /*;zpcon1*/
  948. {
  949.     int    k;
  950.     char    *s;
  951.  
  952.     k = con->const_kind;
  953.     if (k == CONST_OM) s = "om";
  954.     else if (k== CONST_INT) s = "int";
  955.     else if (k == CONST_REAL) s = "real";
  956.     else if (k == CONST_STR) s = "str";
  957.     else if (k == CONST_RAT) s = "rat";
  958.     else if (k == CONST_CONSTRAINT_ERROR) s = "constraint_error";
  959.     else if (k == CONST_UINT) s = "uint";
  960.     else if (k == CONST_FIXED) s = "fixed";
  961.     else s = "INVALID";
  962.     printf(" %s", s);
  963.     if (k == CONST_INT) printf(" %d", con->const_value.const_int);
  964.     else if (k == CONST_UINT)printf(" %s",int_tos(con->const_value.const_uint));
  965.     else if (k == CONST_REAL) printf(" %12.3g", con->const_value.const_real);
  966.     else if (k == CONST_STR) printf(" %s", con->const_value.const_str);
  967.     else if (k == CONST_RAT) zprat1(RATV(con));
  968.     else if (k == CONST_FIXED) printf("%ld", con->const_value.const_fixed);
  969. }
  970.  
  971. static void zprat1(Rational rat)                    /*;zprat1*/
  972. {
  973.     char    *s1, *s2;
  974.  
  975.     s1 = int_tos(rat->rnum);
  976.     s2 = int_tos(rat->rden);
  977.     printf(" %s/%s", s1, s2);
  978.     efreet(s1, "zprat1-num"); 
  979.     efreet(s2, "zprat1-den");
  980. }
  981.  
  982. void zprat(Rational rat)                    /*;zprat*/
  983. {
  984.     zprat1(rat);
  985.     printf("\n");
  986. }
  987.  
  988. void zpnod(Node nod)                    /*;zpnod*/
  989. {
  990.     int    i, seq, unit, has_spans;
  991.     unsigned int nk;
  992.     Symbol    sym;
  993.  
  994.     if (nod == (Node)0) {
  995.         printf("(Node)0\n");
  996.         return;
  997.     }
  998.     printf("=n%du%d", N_SEQ(nod), N_UNIT(nod));
  999.     zpadr((char *)0, (char *) nod);
  1000.     nk = N_KIND(nod);
  1001.     printf(" %s", kind_str(nk));
  1002.     if (N_LIST_DEFINED(nk)) zpadr("n_list", (char *) N_LIST(nod));
  1003.     has_spans = is_terminal_node(nk);
  1004.     if (has_spans) {
  1005.         printf(" n_span %d", N_SPAN0(nod));
  1006.         printf(".%d", N_SPAN1(nod));
  1007.     }
  1008.     sym = (Symbol) 0;
  1009.     /* indicate if overloaded */
  1010.     if (N_OVERLOADED(nod)) printf(" OV ");
  1011.     /* N_UNQ defined only if N_AST3 not defined */
  1012.     if (!N_AST3_DEFINED(nk)) sym = N_UNQ(nod);
  1013.     if (sym != (Symbol)0) { /* only do N_UNQ if not overloaded */
  1014.         if (!N_OVERLOADED(nod)) {
  1015.             seq = S_SEQ(sym); 
  1016.             unit = S_UNIT(sym);
  1017.             zpsymrefa("n_unq", N_UNQ(nod));
  1018.         }
  1019.     }
  1020.     if (!N_AST3_DEFINED(nk)) { /* N_AST3 and N_NAMES overlap */
  1021.         if (N_OVERLOADED(nod)) zpadr("n_names", (char *) N_NAMES(nod));
  1022.     }
  1023.  
  1024.     sym = (Symbol)0;
  1025.     /* N_TYPE defined only if N_AST4 not defined */
  1026.     if (!N_AST4_DEFINED(nk)) sym = N_TYPE(nod);
  1027.     if (!N_OVERLOADED(nod) && sym != (Symbol)0)
  1028.         zpsymrefa("n_type", N_TYPE(nod));
  1029.     if (!N_AST4_DEFINED(nk)) { /* N_PTYPES overlaps N_AST4 */
  1030.         if (N_OVERLOADED(nod)) zpadr("n_ptypes", (char *) N_PTYPES(nod));
  1031.     }
  1032.  
  1033.     if (N_KIND(nod) == as_line_no || N_KIND(nod) == as_number)
  1034.         printf(" %d", (int)N_VAL(nod));
  1035.     else if (N_KIND(nod) == as_ivalue) {
  1036.         printf(" ");
  1037.         zpcon1((Const) N_VAL(nod));
  1038.     }
  1039.     else {
  1040.         if (N_VAL_DEFINED(nk)) zpadr("n_val",  N_VAL(nod));
  1041.         if (N_LIST_DEFINED(nk)) zpadr("n_list",  (char *) N_LIST(nod));
  1042.     }
  1043.     if (N_KIND(nod) == as_simple_name) printf(" %s", N_VAL(nod));
  1044.     printf("\n");
  1045.     if (N_AST1(nod) != (Node) 0 || N_AST2(nod) != (Node) 0
  1046.       || N_AST3(nod) != (Node) 0 || N_AST4(nod) != (Node) 0) {
  1047.         i = 0; /* set if any subnodes found, to see if newline needed*/
  1048.         if (N_AST1_DEFINED(nk) && N_AST1(nod) != (Node) 0)  {
  1049.             zpnodrefa("1", N_AST1(nod));
  1050.             i = 1;
  1051.         }
  1052.         if (N_AST2_DEFINED(nk) &&  N_AST2(nod) != (Node) 0)  {
  1053.             zpnodrefa("2", N_AST2(nod));
  1054.             i = 1;
  1055.         }
  1056.         if (N_AST3_DEFINED(nk) && N_AST3(nod) != (Node) 0)  {
  1057.             zpnodrefa("3", N_AST3(nod));
  1058.             i = 1;
  1059.         }
  1060.         if (N_AST4_DEFINED(nk) && N_AST4(nod) != (Node) 0) {
  1061.             zpnodrefa("4", N_AST4(nod));
  1062.             i = 1;
  1063.         }
  1064.         if (i) printf("\n");
  1065.     }
  1066. #ifdef AMIABLE
  1067.     zpoperand(nod);
  1068. #endif
  1069. }
  1070.  
  1071. void zpnods(int seq, int unit)            /*;zpnods*/
  1072. {
  1073.     /* node dump by sequence and unit number */
  1074.     Node node;
  1075.  
  1076.     node = zgetnodptr(seq, unit);
  1077.     zpnod(node);
  1078. }
  1079.  
  1080. void zpn(int seq, int unit)                    /*;zpn*/
  1081. {
  1082.     /* short name for zpnods */
  1083.     zpnods(seq, unit);
  1084. }
  1085.  
  1086.  
  1087. void zpdnod() /*;zpdnod*/
  1088. {
  1089.     zpnod(znod);
  1090. }
  1091.  
  1092. void zpnodrefa(char *s, Node nod)                    /*;zpnodrefa*/
  1093. {
  1094.     printf(" %s", s); 
  1095.     zpnodref(nod);
  1096.     /*zpadr((char *)0, nod);*/
  1097. }
  1098.  
  1099. void zpdset()    /*;zpdset*/
  1100. {
  1101.     zpset(zset);
  1102. }
  1103.  
  1104. void zpset(Set s)    /*;zpset*/
  1105. {
  1106.     zptup(s);
  1107. }
  1108.  
  1109. void zpdsetsym()    /*;zpdsetsym*/
  1110. {
  1111.     zpsetsym(zset);
  1112. }
  1113.  
  1114. void zpsetsym(Set s)    /*zpsetsym*/
  1115. {
  1116.     Symbol    sym;
  1117.     int n;
  1118.     Forset    fs1;
  1119.  
  1120.     n = set_size(s);
  1121.     printf("setsym %d {", n);
  1122.     if (n>10) n = 10;
  1123.     FORSET(sym = (Symbol), s, fs1);
  1124.         zpsym(sym);
  1125.     ENDFORSET(fs1);
  1126.     printf(" }\n");
  1127. }
  1128.  
  1129. void zpsigs(int seq, int unit)            /*;zpsigs*/
  1130. {
  1131.     /* signature dump by sequence and unit number */
  1132.     Symbol sym;
  1133.     sym = zgetsymptr(seq, unit);
  1134.     zpsig(sym);
  1135. }
  1136.  
  1137. void zpsig(Symbol sym)                /*;zpsig*/
  1138. {
  1139.     int nat, i, n, ctyp;
  1140.     Tuple    sig, tup, tupent;
  1141.     Symbol    s;
  1142.     Fortup    ft1;
  1143.     static char *constraint_types[] = { 
  1144.         "range", "digits", "delta", "discr", "array" };
  1145.  
  1146.  
  1147.     /* The signature field is used as follows:
  1148.      * It is a symbol for:
  1149.      *    na_access
  1150.      * It is a node for
  1151.      *    na_constant  na_in  na_inout
  1152.      * It is also a node (always OPT_NODE) for na_out. For now we write this
  1153.      * out even though it is not used. 
  1154.      * It is a pair for na_array.
  1155.      * It is a triple for na_enum.
  1156.      * It is a triple for na_generic_function_spec na_generic_procedure_spec
  1157.      * The first component is a tuple of pairs, each pair consisting of
  1158.      * a symbol and a (default) node.
  1159.      * The second component is a tuple of symbols.
  1160.      * The third component is a node
  1161.      * It is a tuple with four elements for na_generic_package_spec:
  1162.      * the first is a tuple of pairs, with same for as for generic procedure.
  1163.      * the second third, and fourth components are nodes.
  1164.      * It is a 5-tuple for na_record.
  1165.      * It is a constraint for na_subtype and na_type.
  1166.      * It is a node for na_obj.
  1167.      * Otherwise it is the signature for a procedure, namely a tuple
  1168.      * of quadruples.
  1169.      * Note however, that for a private type, the signature has the same
  1170.      * form as for a record.
  1171.      * For a subtype whose root type is an array, the signature has the
  1172.      * same form as for an array.
  1173.      */
  1174.  
  1175.     nat = NATURE(sym);
  1176.     sig = SIGNATURE(sym);
  1177.     /* treat private types way in same way as for records*/
  1178.     s = TYPE_OF(sym);
  1179.     if (s == symbol_private || s == symbol_limited_private
  1180.       || s== symbol_incomplete) {
  1181.         nat = na_record;
  1182.     }
  1183.     switch (nat) {
  1184.     case na_access:
  1185.         /* access: signature is designated_type;*/
  1186.         zpsymref((Symbol) sig);
  1187.         break;
  1188.  
  1189.     case    na_array:
  1190.         /* array: signature is pair [i_types, comp_type] where
  1191.          * i_type is tuple of type names
  1192.          */
  1193. array_case:
  1194.         printf(" array_sig %d\n", tup_size((Tuple) sig[1]));
  1195.         FORTUP(s = (Symbol), (Tuple) sig[1], ft1);
  1196.             zpsymref(s);
  1197.             printf("\n");
  1198.         ENDFORTUP(ft1);
  1199.         zpsymref((Symbol) sig[2]);
  1200.         printf("\n");
  1201.         break;
  1202.  
  1203.     case    na_block:
  1204.         /* block: miscellaneous information */
  1205.         /* This information not needed externally*/
  1206.         chaos("zpsig: signature for block");
  1207.         break;
  1208.  
  1209.     case    na_constant:
  1210.     case    na_in:
  1211.     case    na_inout:
  1212.     case    na_out:
  1213.     case    na_discriminant:
  1214.         zpnodref((Node) sig);
  1215.         break;
  1216.  
  1217.     case    na_entry:
  1218.     case    na_entry_family:
  1219.     case    na_entry_former:
  1220.         /* entry: list of symbols */
  1221.     case    na_function:
  1222.     case    na_function_spec:
  1223.     case    na_literal:        /* is this for literals too? */
  1224.     case    na_op:
  1225.     case    na_procedure:
  1226.     case    na_procedure_spec:
  1227.         printf(" symbol_list  %d\n", tup_size(sig));
  1228.         FORTUP(s = (Symbol), sig, ft1);
  1229.             zpsymref(s); 
  1230.             printf("\n");
  1231.         ENDFORTUP(ft1);
  1232.         break;
  1233.  
  1234.     case    na_enum:
  1235.         /* enum: tuple in form ['range', lo, hi]*/
  1236.         /* we write this as two node references*/
  1237.         zpnodref((Node) sig[2]);
  1238.         zpnodref((Node) sig[3]);
  1239.         printf("\n");
  1240.         break;
  1241.  
  1242.     case    na_type: 
  1243.     case na_subtype:
  1244.         if (nat == na_subtype && is_access(TYPE_OF(sym))) {
  1245.             /* subtype of access type, signature is anonymous type */
  1246.             zpsymref((Symbol)sig);
  1247.         }
  1248.         else {
  1249.             n = tup_size(sig);
  1250.             if (is_array(sym)) { /* if constrained array */
  1251.                 printf(" constrained_array \n");
  1252.                 goto array_case;
  1253.             }
  1254.             ctyp = (int) sig[1];
  1255.             if (ctyp >= 0 && ctyp <= 4)
  1256.                 printf(" co_%s", constraint_types[ctyp]);
  1257.             else
  1258.                 printf(" unknown constraint type %d", ctyp);
  1259.             if (ctyp == CONSTRAINT_DISCR) {
  1260.                 /* discriminant map */
  1261.                 tup = (Tuple) numeric_constraint_discr(sig);
  1262.                 n = tup_size(tup);
  1263.                 for (i = 1; i <= n; i += 2) {
  1264.                     printf(" %d", (i+1)/2);
  1265.                     zpsymref((Symbol) sig[i]);
  1266.                     zpnodref((Node) sig[i+1]);
  1267.                 }
  1268.             }
  1269.             else {
  1270.                 for (i = 2; i <= n; i++) {
  1271.                     printf(" %d", i);
  1272.                     zpnodref((Node) sig[i]);
  1273.                 }
  1274.             }
  1275.         }
  1276.         printf("\n");
  1277.         break;
  1278.  
  1279.     case    na_generic_function:
  1280.     case    na_generic_procedure:
  1281.     case    na_generic_function_spec:
  1282.     case    na_generic_procedure_spec:
  1283.         if (tup_size(sig) != 3)
  1284.             chaos("zpsig: bad signature for na_generic_procedure_spec");
  1285.         /* tuple count known to be three, just put elements */
  1286.         tup = (Tuple) sig[1];
  1287.         /* the first component is a tuple of pairs, just write count
  1288.          * and the values of the successive pairs 
  1289.          */
  1290.         n = tup_size(tup);
  1291.         printf(" %d\n", n);
  1292.         for (i = 1; i <= n; i++) {
  1293.             tupent = (Tuple) tup[i];
  1294.             zpsymref((Symbol) tupent[1]);
  1295.             zpnodref((Node) tupent[2]);
  1296.             printf("\n");
  1297.         }
  1298.         tup = (Tuple) sig[2];
  1299.         n = tup_size(tup); /* symbol list */
  1300.         printf(" symbol_list %d\n", n);
  1301.         for (i = 1; i <= n; i++) {
  1302.             zpsymref((Symbol) tup[i]); 
  1303.             printf("\n");
  1304.         }
  1305.         printf(" node ");
  1306.         zpnodref((Node) sig[3]);
  1307.         printf("\n");
  1308.         break;
  1309.  
  1310.     case    na_generic_package_spec:
  1311.     case    na_generic_package:
  1312.         /* signature is tuple with three elements */
  1313.         if (tup_size(sig) != 4)
  1314.             chaos("zpsig: bad signature for na_generic_package_spec");
  1315.         tup = (Tuple) sig[1];
  1316.         /* the first component is a tuple of pairs, just write count
  1317.          * and the values of the successive pairs 
  1318.          */
  1319.         n = tup_size(tup);
  1320.         printf(" n %d\n", n);
  1321.         for (i = 1; i <= n; i++) {
  1322.             tupent = (Tuple) tup[i];
  1323.             zpsymref((Symbol) tupent[1]);
  1324.             zpnodref((Node) tupent[2]);
  1325.             printf("\n");
  1326.         }
  1327.         /* the second third, and fourth components are just nodes */
  1328.         zpnodref((Node) sig[2]);
  1329.         zpnodref((Node) sig[3]);
  1330.         zpnodref((Node) sig[4]);
  1331.         printf("\n");
  1332.         break;
  1333.  
  1334.     case    na_record:
  1335.         /* the signature is tuple with five components:
  1336.          * [node, node, tuple of symbols, declaredmap, node]
  1337.          * NOTE: we do not write component count - 5 assumed 
  1338.          */
  1339.         printf(" record (skip details)\n"); 
  1340.         break;
  1341. /*
  1342.         zpnodref((Node) sig[1]);
  1343.         zpnodref((Node) sig[2]);
  1344.         tup = (Tuple) sig[3];
  1345.         n = tup_size(tup);
  1346.         for (i = 1; i <= n; i++)
  1347.             zpsymref((Symbol) tup[i]);
  1348.         zpnodref((Node) sig[5]);
  1349.         break;
  1350. */
  1351.  
  1352.     case    na_void:
  1353.         /* special case assume entry for $used, in which case is tuple
  1354.          * of symbols
  1355.          */
  1356.         if (streq(ORIG_NAME(sym), "$used")) {
  1357.             n = tup_size(sig);
  1358.             printf(" symbol_list %d\n", n);
  1359.             for (i = 1; i <= n; i++) {
  1360.                 zpsymref((Symbol) sig[i]); 
  1361.                 printf("\n");
  1362.             }
  1363.         }
  1364.         else {
  1365.             zpsym(sym);
  1366.             chaos("zpsig: na_void, not $used");
  1367.         }
  1368.         break;
  1369.  
  1370.     case    na_obj:
  1371.         zpnodref((Node) sig); 
  1372.         printf("\n");
  1373.         break;
  1374.  
  1375.     default:
  1376.         printf("zpsig: default error\n");
  1377.         zpsigt();
  1378.     }
  1379. }
  1380.  
  1381. void zpsigt()
  1382. {
  1383. }
  1384.  
  1385. void zptup(Tuple tup) /*;zptup*/
  1386. {
  1387.     int i, n;
  1388.     n = tup_size(tup);
  1389.     printf("size : %d\n", n);
  1390.     if (n>10) n = 10;
  1391.     for (i = 1; i <= n; i++)
  1392.         printf("%d 0x%x %d \n", i, (int)tup[i], (int)tup[i]);
  1393. }
  1394.  
  1395. void zpdtup()
  1396. {
  1397.     zptup(ztup);
  1398. }
  1399.  
  1400. void zpsym(Symbol sym)            /*;zpsym*/
  1401. {
  1402.     /* kind_char gives character for TYPE_KIND - B for byte, etc. */
  1403.     static char kind_char[] = {
  1404.         'U', 'B', 'W', 'A', 'L', 'D', 'X' };
  1405.  
  1406.     if (sym == (Symbol)0) {
  1407.         printf("(Symbol)0\n");
  1408.         return;
  1409.     }
  1410.     printf("=s%du%d", S_SEQ(sym), S_UNIT(sym));
  1411.     zpadr((char *)0, (char *) sym);
  1412.     /*printf(" %d %s ", (int)NATURE(sym), nature_str(NATURE(sym)));*/
  1413.     printf(" %s", nature_str(NATURE(sym)));
  1414.     zpsymrefa("type_of", TYPE_OF(sym));
  1415.     zpsymrefa("scope", SCOPE_OF(sym));
  1416.     zpadr("sig", (char *) SIGNATURE(sym));
  1417.     printf(" %c%d", kind_char[TYPE_KIND(sym)], TYPE_SIZE(sym));
  1418.     /* end line if giving full addresses */
  1419.     if (adrflag) printf("\n");
  1420.     zpadr("overloads", (char *) OVERLOADS(sym));
  1421.     zpadr("dcl", (char *) DECLARED(sym));
  1422.     zpsymrefa("alias", ALIAS(sym));
  1423.     if (TYPE_ATTR(sym)) printf(" type_attr %d", TYPE_ATTR(sym));
  1424.     /* list original name if available, putting : in front to mark it */
  1425.     if (ORIG_NAME(sym) != (char *)0)
  1426.         printf(" :%s", ORIG_NAME(sym));
  1427.     printf("\n");
  1428. }
  1429.  
  1430. void zpsymrefa(char *s, Symbol sym)            /*;zpsymrefa*/
  1431. {
  1432.     if (sym == (Symbol) 0) return;
  1433.     printf(" %s", s);
  1434.     zpsymref(sym);
  1435. }
  1436.  
  1437. void zpsyms(int seq, int unit)            /*;zpsyms*/
  1438. {
  1439.     /* symbol dump by sequence and unit number */
  1440.     Symbol sym;
  1441.     sym = zgetsymptr(seq, unit);
  1442.     zpsym(sym);
  1443. }
  1444.  
  1445. void zpdsym()    /*;zpdsym*/
  1446. {
  1447.     zpsym(zsym);
  1448. }
  1449.  
  1450. void zpdcl(Declaredmap dcl) /*;zpdcl*/
  1451. {
  1452.     Fordeclared    div;
  1453.     char    *str;
  1454.     Symbol    sym;
  1455.  
  1456. #ifdef IBM_PC
  1457.     printf("declared map %p\n", dcl);
  1458. #else
  1459.     printf("declared map %ld\n", dcl);
  1460. #endif
  1461.  
  1462.     FORDECLARED(str, sym, dcl, div)
  1463. #ifdef IBM_PC
  1464.         printf("\"%s\" %p %d\n", str, sym, IS_VISIBLE(div));
  1465. #else
  1466.         printf("\"%s\" %ld %d\n", str, sym, IS_VISIBLE(div));
  1467. #endif
  1468.     ENDFORDECLARED(div)
  1469. }
  1470.  
  1471. void zpddcl() /*;zpddcl*/
  1472. {
  1473.     zpdcl(zdcl);
  1474. }
  1475.  
  1476. void zppdcl(Private_declarations pdcl)                /*;zppdcl*/
  1477. {
  1478.     /* print private declarations */
  1479.     Forprivate_decls    fp;
  1480.     Symbol    s1, s2;
  1481.     int        i = 0;
  1482.  
  1483.     printf("private declared map %d\n", (int)pdcl);
  1484.  
  1485.     FORPRIVATE_DECLS(s1, s2, pdcl, fp)
  1486.         printf("priv decl entry %d \n", ++i);
  1487.         zpsym(s1); 
  1488.         zpsym(s2);
  1489.         printf("\n");
  1490.     ENDFORPRIVATE_DECLS(fp)
  1491. }
  1492.  
  1493. void zppsetsym(Set s)/*;zppsetsym*/
  1494. {
  1495.     zpsetsym(s);
  1496. }
  1497.  
  1498. void zptupsym(Tuple t)/*;zptupsym*/
  1499. {
  1500.     /* print tuple of symbols */
  1501.  
  1502.     int        i, n;
  1503.  
  1504.     n = tup_size(t);
  1505.     if (n == 0) return;
  1506.     printf("%d symbols\n", n);
  1507.     for (i = 1; i <= n; i++) {
  1508.         printf("%d\n", i);
  1509.         zpsym((Symbol) t[i]);
  1510.     }
  1511. }
  1512.  
  1513. void zptupnod(Tuple t)/*;zptupnod*/
  1514. {
  1515.     /* print tuple of nodes */
  1516.  
  1517.     int        i, n;
  1518.  
  1519.     n = tup_size(t);
  1520.     if (n == 0) return;
  1521.     printf("%d nodes\n", n);
  1522.     for (i = 1; i <= n; i++) {
  1523.         printf("%d\n", i);
  1524.         zpnod((Node) t[i]);
  1525.     }
  1526. }
  1527.  
  1528. void zpsmap(Symbolmap smap)                    /*;zpsmap */
  1529. {
  1530.     int i, n;
  1531.     Tuple tup;
  1532.     tup = smap->symbolmap_tuple;
  1533.     n = tup_size(tup);
  1534.     printf("%d entries\n", n/2);
  1535.     for (i = 1; i<n; i += 2) {
  1536.         printf("%d:\n", (i/2)+1);
  1537.         zpsym((Symbol) tup[i]);
  1538.         zpsym((Symbol) tup[i+1]);
  1539.     }
  1540. }
  1541.  
  1542. void zpdmap(Nodemap dmap)                    /*;zpdmap */
  1543. {
  1544.     int i, n;
  1545.     Tuple tup;
  1546.  
  1547.     tup = dmap->nodemap_tuple;
  1548.     n = tup_size(tup);
  1549.     printf("%d entries\n", n/2);
  1550.     for (i = 1; i<n; i += 2) {
  1551.         printf("%d:\n", (i/2)+1);
  1552.         zpnod((Node) tup[i]);
  1553.         zpnod((Node) tup[i+1]);
  1554.     }
  1555. }
  1556.  
  1557. void trapn(Node node)                    /*;trapn*/
  1558. {
  1559.     /* called on reference to trapped node */
  1560.     zpnod(node);
  1561. }
  1562.  
  1563. void traps(Symbol sym)                    /*;traps*/
  1564. {
  1565.     /* called on reference to trapped symbol */
  1566.     zpsym(sym);
  1567. }
  1568.  
  1569. void trapini()                    /*;trapini*/
  1570. {
  1571.     FILE    *tfile;
  1572.  
  1573.     trapns = trapnu = trapss = trapsu = 0;
  1574.     tfile = efopen("trapf", "r", "t");
  1575.     if (tfile == (FILE *)0) return;
  1576.     fscanf(tfile, "%d%d%d%d", &trapss, &trapsu, &trapns, &trapnu);
  1577.     if (trapns | trapnu | trapss | trapsu) {
  1578.         printf("trap set ss %d su %d ns %d nu %d\n", trapss, trapsu,
  1579.           trapns, trapnu);
  1580.     }
  1581.     fclose(tfile);
  1582. }
  1583.  
  1584. void trapset(int ns, int nu, int ss, int su)                /*;trapset*/
  1585. {
  1586.     printf("trapset ns %d nu %d ss %d su %d\n", ns, nu, ss, su);
  1587.     trapns = ns; 
  1588.     trapnu = nu; 
  1589.     trapss = ss; 
  1590.     trapsu = su;
  1591. }
  1592.  
  1593. Node zgetnodptr(int seq, int unit)        /*;zgetnodptr*/
  1594. {
  1595.     /* here to convert seq and unit to pointer to symbol.
  1596.      * we require that the symbol has already been allocated
  1597.      * This is variant of getnodptr; however it does not raise chaos
  1598.      * if node not found, but just prints error message
  1599.      */
  1600.  
  1601.     Tuple    nodptr;
  1602.     Node    node;
  1603.  
  1604.     /* TBSL: need to get SEQPTR table for unit, and return address
  1605.      */
  1606.     if (unit == 0) {
  1607.         if (seq == 1) return OPT_NODE;
  1608.         if (seq == 0) return (Node)0;
  1609.         if (seq>0 && seq <= tup_size(init_nodes)) {
  1610.             node = (Node) init_nodes[seq];
  1611.             return node;
  1612.         }
  1613.         else {
  1614.             printf(" zgetnodptr - node s%du%d not found \n", seq, unit);
  1615.             return (Node) 0;
  1616.         }
  1617.     }
  1618.     if (unit <= unit_numbers) {
  1619.         nodptr = (Tuple) pUnits[unit]->treInfo.tableAllocated;
  1620.         if (seq == 0) {
  1621.             printf(" zgetnodptr - node s%du%d not found \n", seq, unit);
  1622.             return (Node) 0;
  1623.         }
  1624.         if (seq <= tup_size(nodptr)) {
  1625.             node = (Node) nodptr[seq];
  1626.             if (node == (Node)0) {/* here to allocate node on first reference */
  1627.                 node = node_new_noseq(as_unread);
  1628.                 N_SEQ(node) = seq;
  1629.                 N_UNIT(node) = unit;
  1630.                 nodptr[seq] = (char *) node;
  1631.             }
  1632.             return node;
  1633.         }
  1634.     }
  1635.     printf(" zgetnodptr - node s%du%d not found \n", seq, unit);
  1636.     return (Node) 0;
  1637. }
  1638.  
  1639. Symbol zgetsymptr(int seq, int unit)        /*;getsymptr*/
  1640. {
  1641.     /* here to convert seq and unit to pointer to symbol.
  1642.      * we require that the symbol has already been allocated
  1643.      * this is variant of getsymptr; it does not raise chaos if
  1644.      * symbol cannot be found, but just prints error message
  1645.      */
  1646.  
  1647.     Tuple    symptr;
  1648.     Symbol    sym;
  1649.     int    items;
  1650.  
  1651.     /* TBSL: need to get SEQPTR table for unit, and return address
  1652.      */
  1653.     if (unit == 0) {
  1654.         if (seq == 0) return (Symbol)0;
  1655.         if (seq>0 && seq <= tup_size(init_symbols)) {
  1656.             sym = (Symbol) init_symbols[seq];
  1657.             return sym;
  1658.         }
  1659.         else {
  1660.             chaos("unit 0 error getsymptr");
  1661.         }
  1662.     }
  1663.     if (unit <= unit_numbers) {
  1664.         struct unit *pUnit = pUnits[unit];
  1665.         symptr = (Tuple) pUnit->aisInfo.symbols;
  1666.         if (symptr == (Tuple)0) {
  1667.             items = pUnit->aisInfo.numberSymbols;
  1668.             symptr = tup_new(items);
  1669.             pUnit->aisInfo.symbols = (char *) symptr;
  1670.         }
  1671.         if (seq <= tup_size(symptr)) {
  1672.             sym = (Symbol) symptr[seq];
  1673.             if (sym == (Symbol)0) {
  1674.                 sym = sym_new_noseq(na_void);
  1675.                 symptr[seq] = (char *) sym;
  1676.                 S_SEQ(sym) = seq;
  1677.                 S_UNIT(sym) = unit;
  1678.             }
  1679.             if (trapss>0 && seq == trapss && unit == trapsu) traps(sym);
  1680.             return sym; /* return newly allocated symbol */
  1681.         }
  1682.         else {
  1683.             printf(" zgetsymptr: symbol not found, return 0\n");
  1684.             return (Symbol) 0;
  1685.         }
  1686.     }
  1687.     printf(" zgetsymptr: symbol not found, return 0\n");
  1688.     return (Symbol) 0;
  1689. }
  1690.  
  1691. void zpsymref(Symbol sym)                /*;zpsymref*/
  1692. {
  1693.     /* print symbol sequence and unit */
  1694.  
  1695.     int    seq, unit;
  1696.  
  1697.     if (sym != (Symbol)0) {
  1698.         seq = S_SEQ(sym);
  1699.         unit = S_UNIT(sym);
  1700.     }
  1701.     else {
  1702.         seq = 0; 
  1703.         unit = 0;
  1704.     }
  1705.     printf(" s%du%d", seq, unit);
  1706. }
  1707.  
  1708. void zpnodref(Node nod)                /*;zpnodref*/
  1709. {
  1710.     /* print node sequence and unit */
  1711.  
  1712.     int    seq, unit;
  1713.  
  1714.     if (nod != (Node)0) {
  1715.         seq = N_SEQ(nod);
  1716.         unit = N_UNIT(nod);
  1717.     }
  1718.     else {
  1719.         seq = 0; 
  1720.         unit = 0;
  1721.     }
  1722.     printf(" n%du%d", seq, unit);
  1723. }
  1724.  
  1725. void zpunit(int unum)                /*;zpunit*/
  1726. {
  1727.     /* print information for nodes and symbols in specified  unit */
  1728.  
  1729.     Tuple stup, ntup, sig;
  1730.     int    nodes, symbols, i, rootseq, j, n;
  1731.     Node    first_node, unit_node, nod;
  1732.     Symbol    sym;
  1733.     struct unit *pUnit;
  1734.  
  1735.     /* disable address printing */
  1736.     adrflag = FALSE;
  1737.     if (unum > 0) {
  1738.         pUnit = pUnits[unum];
  1739.         nodes = pUnit->treInfo.nodeCount;
  1740.         ntup = (Tuple) pUnit->treInfo.tableAllocated;
  1741.         symbols = pUnit->aisInfo.numberSymbols;
  1742.         stup = (Tuple) pUnit->aisInfo.symbols;
  1743.         printf("unit dump for unit %d %s\n", unum, pUnit->name);
  1744.         /* rootseq doesn't seem used - bp */
  1745.         rootseq = 0;
  1746.         first_node = (Node) getnodptr(rootseq, unit_number_now);
  1747.         unit_node = N_AST2(first_node);
  1748.     }
  1749.     else { /* if dumping unit 0 */
  1750.         nodes = seq_node_n;
  1751.         ntup = tup_copy(seq_node);
  1752.         ntup[0] = (char *) seq_node_n;
  1753.         symbols = seq_symbol_n;
  1754.         stup = tup_copy(seq_symbol);
  1755.         stup[0] = (char *) seq_symbol_n;
  1756.         printf("unit dump for unit 0\n");
  1757.     }
  1758.     for (i = 1; i <= symbols; i++) {
  1759.         sym = (Symbol) stup[i];
  1760.         if (sym != (Symbol)0) {
  1761.             zpsym(sym);
  1762.             sig = SIGNATURE(sym);
  1763.             if (sig != (Tuple)0) zpsig(sym);
  1764.         }
  1765.     }
  1766.     for (i = 1; i <= nodes; i++) {
  1767.         nod = (Node) ntup[i];
  1768.         if (nod != (Node)0) {
  1769.             zpnod(nod);
  1770.             sig = N_LIST(nod);
  1771.             if (sig != (Tuple)0) { /* print N_LIST if present */
  1772.                 n = tup_size(sig);
  1773.                 printf(" n_list %d ", tup_size(sig));
  1774.                 for (j = 1; j <= n; j++)
  1775.                     zpnodref((Node) sig[j]);
  1776.                 printf("\n");
  1777.             }
  1778.         }
  1779.     }
  1780.     if (unum == 0) { /* free node and symbol tuples for unit 0 */
  1781.         tup_free(stup);
  1782.         tup_free(ntup);
  1783.     }
  1784.     adrflag = TRUE; /* restore address print flag */
  1785. }
  1786.  
  1787. void zpint(int n)            /*;zpint*/
  1788. {
  1789.     /* print n at int */
  1790.     char ch;
  1791.  
  1792.     ch = (char) n;
  1793.     ch = isascii(ch) && isprint(ch) ? ch : ' ';
  1794.     printf(" %d %u %x %c  :duxc\n", n, n, n, ch);
  1795. }
  1796. #endif
  1797.